;;########################################################################
;; freqplg1.lsp
;; Copyright (c) 1999-2002 by Forrest W. Young
;; Continuation of ViSta Plugin for Frequency Analysis.
;;########################################################################


  
  
(defmeth freq-plugin-object-proto :freq-var? (dob)
"Returns freq var name, if there is one, nil otherwise"
  (let ((freq?)(varname))   
    (setf varname (string-downcase
                   (first (send dob :active-variables '(numeric)))))
    (when (and (> (length varname) 3) (equal "freq" (subseq varname 0 4)))
          (setf freq? t))
    (if freq? varname nil)))

; PLUGIN STEP 5: SLOT ACCESSORS

(defmeth freq-plugin-object-proto :table-vars 
  (&optional (string-list nil set))
"List of strings"
  (if set (setf (slot-value 'table-vars) string-list))
  (slot-value 'table-vars))

(defmeth freq-plugin-object-proto :control-vars  
  (&optional (string-list nil set))
"List of strings."
  (if set (setf (slot-value 'control-vars ) string-list))
  (slot-value 'control-vars ))

(defmeth freq-plugin-object-proto :freq-var 
  (&optional (string nil set))
"String"
  (if set (setf (slot-value 'freq-var) string))
  (slot-value 'freq-var))

(defmeth freq-plugin-object-proto :table-labels 
  (&optional (string-list nil set))
"List of strings"
  (if set (setf (slot-value 'table-labels) string-list))
  (slot-value 'table-labels))

(defmeth freq-plugin-object-proto :control-labels  
  (&optional (string-list nil set))
"List of strings."
  (if set (setf (slot-value 'control-labels) string-list))
  (slot-value 'control-labels))

(defmeth freq-plugin-object-proto :nways (&optional (value nil set))
"Number of ways of the data."
  (if set (setf (slot-value 'nways) value))
  (slot-value 'nways))

(defmeth freq-plugin-object-proto :chisq 
  (&optional (chisq-value nil set))
"List of lists, one for each matrix of the data array. The elements of a sublist are the chisq, and its df and p for the submatrix."
  (if set (setf (slot-value 'chisq) chisq-value))
  (slot-value 'chisq))
  
(defmeth freq-plugin-object-proto :binomial 
  (&optional (binomial-value nil set))
"List of binomial coefficients for each submatrix of the data array."
  (if set (setf (slot-value 'binomial) binomial-value))
  (slot-value 'binomial))
  
(defmeth freq-plugin-object-proto :phi
  (&optional (phi-value nil set))
"List of phi coefficients for each submatrix of the data array."
  (if set (setf (slot-value 'phi) phi-value))
  (slot-value 'phi))

(defmeth freq-plugin-object-proto :cmh
  (&optional (cmh-value nil set))
"List of lists, one for each bmatrix of the data array. The elements of a sublist are the cmh, its df and its p for the bmatrix."
  (if set (setf (slot-value 'cmh) cmh-value))
  (slot-value 'cmh))

(defmeth freq-plugin-object-proto :observed-data-matrices
  (&optional (list-of-matrices nil set))
  (if set (setf (slot-value 'observed-data-matrices) list-of-matrices))
  (slot-value 'observed-data-matrices))

(defmeth freq-plugin-object-proto :matrix-index-list
  (&optional (list-of-matrices nil set))
  (if set (setf (slot-value 'matrix-index-list) list-of-matrices))
  (slot-value 'matrix-index-list))

(defmeth freq-plugin-object-proto :expected-data-matrices
  (&optional (list-of-matrices nil set))
  (if set (setf (slot-value 'expected-data-matrices) list-of-matrices))
  (slot-value 'expected-data-matrices))

(defmeth freq-plugin-object-proto :freqclass-data-matrix
  (&optional (matrix nil set))
  (if set (setf (slot-value 'freqclass-data-matrix) matrix))
  (slot-value 'freqclass-data-matrix))

; PLUGIN STEP 6: OPTIONS METHOD

(defmeth freq-plugin-object-proto :options ()
"Args: none
This method constructs and displays the options dialog window for frequency models
when a dialog box is requested and needed. The method places appropriate information in the table and control variable slots. Returns nil when dialog canceled or when no table variables are selected, returns t otherwise."
    (cond
     ((or (not (send self :dialog)) 
          (< (length (send self :active-array-variables)) 3))
      t)
      (t
       (let* ((freq-mob self)
              (box-text "Frequency Analysis Options")
              (box-text-item (send text-item-proto :new  box-text))
              (select-toggle (send choice-item-proto :new 
                                   (list "Select Table Variables"
                                         "Select Control Variables") 
                                   :value 0))
              (catg-text-item (send text-item-proto :new "Selectable Variables"))
              (tabl-text-item (send text-item-proto :new "Table Variables"))
              (cntl-text-item (send text-item-proto :new "Control Variables"))
              (catg-var-list  (send self :active-variables '(category)))
              (tabl-var-list  (repeat " " 2))
              (cntl-var-list  (repeat " " 2))
              (catg-list-item (send list-item-proto :new catg-var-list))
              (tabl-list-item (send list-item-proto :new tabl-var-list))
              (cntl-list-item (send list-item-proto :new cntl-var-list))
              (ok     (send modal-button-proto :new "OK"))
              (cancel (send modal-button-proto :new "Cancel"))
              (dialog-item-list 
               (list    
                box-text-item
                select-toggle
                (list (list catg-text-item catg-list-item)
                      (list tabl-text-item tabl-list-item
                            cntl-text-item cntl-list-item))
                (list ok cancel)))
              (freq-dialog 
               (send modal-dialog-proto :new dialog-item-list 
                     :go-away nil :default-button ok)))
         (send tabl-list-item :slot-value 'list-data #())
         (send cntl-list-item :slot-value 'list-data #())
         (defmeth freq-dialog :switch-element (me you your-max-L)
           (let* ((n (send me :selection))
                  (my-list   (send me  :slot-value 'list-data))
                  (your-list (send you :slot-value 'list-data))
                  (L-me  (length my-list))
                  (L-you (length your-list))
                  (s nil))
             (when n
                   (send me :selection nil)
                   (when (and (< n L-me) (< L-you your-max-L))
                         (setf s (select my-list n))
                         (when (< n (1- L-me))
                               (dolist (i (iseq n (- L-me 2)))
                                       (send me :set-text i 
                                             (select my-list (1+ i)))))
                         (send me :set-text (1- L-me) " ")
                         (send me :slot-value 'list-data
                               (select (send me :slot-value 'list-data) 
                                       (iseq (1- L-me))))
                         (send you :slot-value 'list-data
                               (concatenate 'vector your-list (vector s)))
                         (send you :set-text L-you s)))))
         (defmeth catg-list-item :do-action (&optional dbl-clk)
           (let ((toggle (send select-toggle :value)))
             (send  freq-dialog :switch-element catg-list-item 
                    (if (= 0 toggle) tabl-list-item cntl-list-item) 2)))
         (defmeth tabl-list-item :do-action (&optional dbl-clk)
           (send  freq-dialog :switch-element 
                  tabl-list-item catg-list-item 4))
         (defmeth cntl-list-item :do-action (&optional dbl-clk)
           (send  freq-dialog :switch-element 
                  cntl-list-item catg-list-item 4))
         (defmeth ok :do-action ()
           (let ((dialog (send ok :dialog))
                 (table-items (send tabl-list-item :item-list)))
             (cond 
               ((< (length (remove " " table-items :test #'equal)) 1)
                (error-message "You must either 1) select one or two table variables or 2) cancel the dialog box."))
               (t (send freq-mob :table-vars table-items)
                  (send freq-mob :control-vars (send cntl-list-item :item-list))
                  (send dialog :modal-dialog-return t)))))
         (setf return-value (send freq-dialog :modal-dialog))
         return-value))
      ))

; PLUGIN STEP 7: ANALYSIS METHOD

(defmeth freq-plugin-object-proto :analysis ()
  (let* (
         (dob (send self :data-object))
         (active-cat-vars (if (equal (send self :data-type) "freq")
                              (send self :table-vars)
                              (send self :active-variables '(category))))
         (sizes (array-dimensions (send self :data-array)))
         (nways (if (> (length sizes) 2)
                    (length sizes)
                    (if (= (min sizes) 1) 1 2)))
         
         (table-vars (send self :table-vars))
         (n-table-vars (length table-vars))
         (cntl-vars (send self :control-vars))
         (freq-var (send self :freq-var))
         (table-vars-positions 
           (mapcar #'(lambda (tab-var)
                       (position tab-var active-cat-vars :test #'equal))
                   table-vars))
         (table-labels 
          (select (send self :array-labels) table-vars-positions))
         (cntl-vars-positions 
          (if cntl-vars
              (mapcar #'(lambda (cntl-var)
                           (position cntl-var active-cat-vars :test #'equal))
                       cntl-vars)
              nil))
         (control-labels 
          (select (send self :array-labels) cntl-vars-positions))
         (analysis-vars (if cntl-vars
                            (combine table-vars cntl-vars)
                            table-vars))
         (results (if (equal (send dob :data-type) "freq")
                      nil ;this branch only for 2way freq table
                      (send self :make-array :stuff-slots t 
                            :freq (not (not freq-var))  
                            :category-variables analysis-vars
                            :numeric-variables 
                            (if freq-var (list freq-var) nil))))
         (matrices)
         (min-f)
         )
    (send self :nways nways)
    (when (not results);used when two-way freq table
          (send self :freq-array (send dob :freq-array))
          (send self :data-array (send dob :data-array))
          (send self :array-labels (send dob :array-labels))
          (send self :array-variables (send dob :array-variables)))
    (send self :table-labels table-labels)
    (send self :control-labels control-labels) 
    (setf results (array-list (send self :freq-array) (iseq n-table-vars) t))
    (setf matrices (first results)) 
    (setf min-f (min (combine matrices))) 
    (cond
      ((not min-f) 
       (fatal-message "Since some of the cells in the frequency table have zero frequency, the frequency table resulting from the selected category variables cannot be analyzed.  Try choosing fewer or different variables or variables with fewer categories."))
      ((< min-f 6) (warning-message "Some cells in these data have low frequencies (f<6). The analysis is based on asymptotic assumptions which probably do not hold.  Consider choosing fewer variables with fewer categories.")))
    (send self :observed-data-matrices matrices)
    (send self :matrix-index-list (second results))
    (send self :make-freqclass-data-matrix)
    (send self :labels (send self :make-dob-labels))
    (mapcar #'(lambda (freq-matrix) 
                (send self :freq-stats freq-matrix)) 
            matrices)
    (when (> nways 1)
          (send self :cmh (append (send self :cmh)
                                  (list (send self :compute-cmh 
                                              (send self :freq-array))))))
    ))                                                     


(defmeth freq-plugin-object-proto :compute-cmh (array)
  (let* ((cmh (cmh array))
         (cmh-df (cmh-df array))
         (cmh-p  (cmh-p cmh cmh-df)))
    (list cmh cmh-df cmh-p)))

(defmeth freq-plugin-object-proto :freq-stats (x)
"Arg: X
Calculates freq stats for one-way or two-way (sub)array X and puts them in slots."
  (let* ((expected   (chisq-expected x))
         (sizes (array-dimensions x))
         (chisq-x    (if expected (chisq X ) nil))
         (chisq-df-x (if chisq-x (chisq-df X) nil))
         (chisq-p-x  (if chisq-x (chisq-p-value chisq-x chisq-df-x) nil))
         (phi-x) (binomial-x)
         )
    (send self :chisq (append (send self :chisq) 
                (list (list chisq-x chisq-df-x chisq-p-x expected))))
    (when (> (length sizes) 1)
          (setf phi (if (or (not chisq-x) (= 0 (sum x)))
                        nil 
                        (sqrt (/ chisq-x (sum x))))))
    (when (and (= 1 (first sizes)) (= (second sizes) 2))
          (binomial-x (if chisq-x (- 1 (normal-cdf (sqrt chisq-x)))
                          nil)))
    (send self :expected-data-matrices 
          (append (send self :expected-data-matrices) (list expected)))
    (send self :phi (append (send self :phi) (list (phi x))))
    (send self :binomial 
          (append (send self :binomial) (list (binomial x))))
    (unless (= (send self :nways) 1)
            (send self :cmh (append (send self :cmh) (list (send self :compute-cmh x)))))
    ))

(defmeth freq-plugin-object-proto  :make-freqclass-data-matrix ()
  (send self :freqclass-data-matrix (send self :convert-array2freqclass)))

(defmeth freq-plugin-object-proto  :make-dob-labels ()
  (let* ((freqclass-data-rows (row-list (send self :freqclass-data-matrix)))
         ;(vars (send self :active-array-variables))
         (labels
           (mapcar #'(lambda (vars)
                       (let* ((cat-vars (rest (coerce vars 'list)))
                              (n-1 (1- (length cat-vars)))
                              (label (select cat-vars 0)))
                         (when (> n-1 0)
                           (dotimes (i n-1)
                             (setf label (strcat label "|" (select cat-vars (1+ i))))))
                         label
                         ))
                   freqclass-data-rows)))
    labels))

; PLUGIN STEP 8: REPORT METHOD

(defmeth freq-plugin-object-proto :report (&key (dialog nil))
  (let* ((w (report-header (send self :title) :page t))
         (observed-data-matrices (send self :observed-data-matrices))
         (matrix-index-list (send self :matrix-index-list))
         (nmats (length observed-data-matrices))
         (nways (send self :nways))
         (table-vars (send self :table-vars))
         (cntl-vars (send self :control-vars))
         (cmh-list (if (send self :cmh)
                       (first (last (send self :cmh)))
                       nil))
         (sizes (array-dimensions (first observed-data-matrices)))
         (reported-sizes sizes)
         (way-labels (send self :array-labels))
         (reported-ways table-vars)
         (reported-levels way-labels)
         (2x2 (and (= (first sizes) 2) (= (second sizes) 2)))
         (real-way)
         )
    (when (= nways 1)
          (setf real-way (if (= 0 (position 1 sizes)) 1 0))
          (setf reported-sizes (select sizes real-way))
          (setf reported-ways (select table-vars real-way))
          (setf reported-levels (select way-labels real-way)))
    (display-string 
     (format nil "Frequency Analysis: ~a Data~%"
             (send (send self :data-object) :name)) w)
    (display-string
     (format nil "~%Number of Ways:     ~d" nways) w)
    (display-string
     (format nil "~%Number of Levels:   ~a" reported-sizes) w)
    (display-string
     (format nil "~%Ways:   ~a" reported-ways) w)
    (display-string
     (format nil "~%Levels: ~a" reported-levels) w)
    (when cntl-vars 
          (display-string
     (format nil "~%Control   Ways:     ~a" cntl-vars) w))
    (mapcar #'(lambda (i mat mat-index)
                (send self :report-matrix w i mat mat-index 2x2))
            (iseq nmats) observed-data-matrices matrix-index-list)
    (when (and 2x2 (> (length observed-data-matrices) 1))
          (display-string (format nil "~2%Cochran-Mantel-Haenszel Test of General Association~2%The CMH statistic tests for association between~%~a and ~a, adjusting for the effect~%of the control variables on the association."
                   (first table-vars) (second table-vars)) w)
          (display-string 
           (format nil "~2%Cochran-Mantel-Haenszel =~10,4f    DF=~a    P=~10,4f~%" 
                   (fuzz (first cmh-list) 4)
                   (second cmh-list)
                   (fuzz (third cmh-list) 4)) w))
    (send w :fit-window-to-text)))
    
(defmeth freq-plugin-object-proto :report-matrix (w i matrix matrix-index 2x2)
  (let* ((row-sums (mapcar #'sum (row-list matrix)))
         (col-sums (mapcar #'sum (column-list matrix)))
         (sum-sums (sum row-sums))
         (chisq-list (select (send self :chisq) i))
         ;(col-sums+sum-sums (combine col-sums sum-sums))
         (sizes (array-dimensions matrix))
         (r-1 (1- (first sizes)))
         (s-1 (1- (second sizes)))
         (observed (border-matrix-with-sums matrix))
         (expected (border-matrix-with-sums (fourth chisq-list)))
         (row-percents (if (which (= 0 row-sums))
                           nil
                           (border-matrix-with-sums 
                            (* 100 (matmult 
                                    (diagonal (/ (mapcar #'sum (row-list matrix))))
                                    matrix)))))
         (row-percents 
          (apply 'bind-rows (append (butlast (row-list row-percents))
                                    (map-elements #'(lambda (x) (* 100 (/ x sum-sums)))
                                                  (last (row-list observed)))))); PV 10/10/2007
         (col-percents (if (which (= 0 col-sums))
                           nil
                           (border-matrix-with-sums
                            (* 100 (matmult 
                                    matrix 
                                    (diagonal (/ (mapcar #'sum (column-list matrix)))))))))
          (col-percents 
           (apply 'bind-columns (append (butlast (column-list col-percents))
                                        (map-elements #'(lambda (x) (* 100 (/ x sum-sums)))
                                                      (last (column-list observed)))))); PV 10/10/2007
         (control-vars (send self :control-vars))
         (control-levels (remove "!" matrix-index :test #'equal))
         (array-vars (send self :array-variables))
         (table-vars (send self :table-vars))
         (array-labels (send self :array-labels))
         (table-labels (send self :table-labels))
         (control-labels (send self :control-labels))
         (chisq-list (select (send self :chisq) i))
         (phi (select (send self :phi) i))
         (contingency (/ phi (sqrt (1+ (^ phi 2)))))
         (cmh (send self :cmh))
         (cmh (if cmh (select (send self :cmh) i) nil))
         )
    (when control-vars 
          (display-string 
           (format nil "~3%Results while controlling for ") w)
          (dotimes (ii (length control-vars))
                   (display-string 
                    (format nil "~%~a" (select control-vars ii)) w)
                   (display-string 
                    (format nil "[~a]" (select (select control-labels ii)
                                               (select control-levels ii))) w)))
         
    (display-string (format nil "~2%Frequencies:~%") w)
    (print-matrix-to-window observed w 
         :row-heading (first (send self :table-vars))
         :column-heading (second (send self :table-vars))
         :row-labels (combine (first (send self :array-labels)) "Column Sums")
         :column-labels (combine (second (send self :array-labels)) "Row Sums"))
    (cond 
      ((or (not (first chisq-list)) (not row-percents) (not col-percents))
       (display-string (format nil 
          "Cannot calculate statistics due to zero marginal sums.") w))
      (t
       (display-string (format nil "~%Expected Values:~%") w)
       (print-matrix-to-window expected w 
         :row-heading (first (send self :table-vars))
         :column-heading (second (send self :table-vars))
         :row-labels (combine (first (send self :array-labels)) 
                                                    "Column Sums")
         :column-labels (combine (second (send self :array-labels))
                                                       "Row Sums"))
       (display-string (format nil "~%Row Percentages:~%") w)
       (when (> s-1 0)
             (print-matrix-to-window row-percents w 
                               :row-heading (first (send self :table-vars))
                               :column-heading (second (send self :table-vars))
                               :row-labels (combine (first (send self :array-labels)) 
                                                    "Column %")
                               :column-labels (combine (second (send self :array-labels))
                                                       "Row Sums")))
       (when (> r-1 0)
             (display-string (format nil "~%Column Percentages:~%") w)
             (print-matrix-to-window col-percents w 
                   :row-heading (first (send self :table-vars))
                   :column-heading (second (send self :table-vars))
                   :row-labels (combine (first (send self :array-labels)) 
                                                    "Column Sums")
                   :column-labels (combine (second (send self :array-labels))
                                                       "Row %")))
       (display-string (format nil "~2%Statistics:~%") w)
       (display-string 
             (format nil "Chi Square Coefficient  =~10,4f    DF=~a    P=~10,4f~%" 
                (fuzz (first chisq-list) 4)
                (second chisq-list)
                (fuzz (third chisq-list) 4)) w)
       (when 2x2
             (display-string
              (format nil "Cochran-Mantel-Haenszel =~10,4f    DF=~a    P=~10,4f~%"
                      (first cmh) (second cmh) (third cmh)) w))
       (display-string
        (format nil "Phi Coefficient         =~10,4f~%"phi) w)
       (display-string
        (format nil "Contingency Coefficient =~10,4f"contingency) w)
       (when control-vars (display-string (format nil 
         "~1%_____________________________________________~%") w))
       ))))


; PLUGIN STEP 8: CREATE DATA

(defmeth freq-plugin-object-proto :create-data 
  (&key (dialog nil)
        (observed nil)
        (all t))
"Args: DIALOG (observed t) (all t)
Creates 1 or 2 output data objects. If DIALOG=T then presents dialog to determine which objects created. Otherwise presents specified objects. If no options, specified, creates both data objects."
  (if (not (eq current-object self)) (setcm self)) 
  (let ((creator (send *desktop* :selected-icon))
        (desires (list (list (if observed 0) (if all 1) )))
        )
    (cond 
      (dialog
       (setf desires 
             (choose-subset-dialog "Choose Desired Data Objects"
                  '("Analyzed Observed Data (Re-Ordered)"
                    "Observed, Expected and Residuals")
                   :initial (select desires 0))))
      (t
       (setf desires 
             (list (list (if observed 0) (if all 1) )))))
    
    (when desires
          (when (member '0 (select desires 0))
                (send current-model :create-data-object creator 0))
          (when (member '1 (select desires 0))
                (send current-model :create-data-object creator 1)))
    (not (not desires))))

(defmeth freq-plugin-object-proto  :create-data-object (creator type)
  (let* ((freqclass-data-matrix (send self :freqclass-data-matrix))
         (freqclass-data-vars (column-list freqclass-data-matrix))
         (classify-data (rest  freqclass-data-vars))
         (observed-data (first freqclass-data-vars))
         (expected-data (combine (send self :expected-data-matrices)))
         (residual-data (- observed-data expected-data))
         (freqclass-matrix)
         (vars (send self :active-array-variables))
         (numcat (length vars))
         (numnum 1)
         (labels (send self :make-dob-labels))
         (string)
         )
    
    (case type
      (0 (setf string "In")
         (setf string1 "Reordered Observed Frequencies for ")
         (setf vars (combine vars string))
         (setf freqclass-matrix 
               (apply #'bind-columns 
                      (append classify-data (list observed-data)))))
      (1 (setf string "Out")
         (setf string1 "Reordered Observed and Expected Frequencies and Residual Differences for")
         (setf numnum 3)
         (setf vars (combine vars (list "Observed" "Expected" "Residuals")))
         (setf freqclass-matrix 
               (apply #'bind-columns 
                      (append classify-data (list observed-data
                                                  expected-data
                                                  residual-data)))))
      ) 
    (data (strcat string "-" (send self :name))
          :created creator
          :creator-object self
          :freq (= type 0)
          :title (strcat string1 (send self :title))
          :data (combine freqclass-matrix)
          :variables vars
          :labels labels
          :types (combine (repeat "Category" numcat) (repeat "Numeric" numnum)))
    ))




; PLUGIN STEP 9: VISUALIZATION METHOD


(defmeth freq-plugin-object-proto :visualize (&key dialog)
  (send *watcher* :show-window)
  (send (send self :data-object) :visualize-freq-array)
  (send *watcher* :hide-window))



(provide "freqplg1")
